Tcl Source Code

 */

void
Tcl_DeleteNamespace(
    Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */
{
    Namespace *nsPtr = (Namespace *) namespacePtr;
    Tcl_Interp *interp = nsPtr->interp;
    Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);

    Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Command *cmdPtr;

    /*
     * Ensure that this namespace doesn't get deallocated in the meantime.
     */

     * separate list of coros.
     */

    for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	    entryPtr != NULL;) {
	cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
	if (cmdPtr->nreProc == TclNRInterpCoroutine) {
	    Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);

	    entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	} else {
	    entryPtr = Tcl_NextHashEntry(&search);
	}
    }

    /*

	/*
	 * Splice out and link to indicate that we've already been killed.
	 */

	nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
	ensemblePtr->next = ensemblePtr;
	Tcl_DeleteCommandFromToken(interp, ensemblePtr->token);
    }

    /*
     * If the namespace has a registered unknown handler (TIP 181), then free
     * it here.
     */

	 * being deleted, ignore any second call.
	 */

	nsPtr->flags |= (NS_DYING|NS_KILLED);

	TclTeardownNamespace(nsPtr);

	if ((nsPtr != globalNsPtr) || (((Interp *) interp)->flags & DELETED)) {
	    /*
	     * If this is the global namespace, then it may have residual
	     * "errorInfo" and "errorCode" variables for errors that occurred
	     * while it was being torn down. Try to clear the variable list
	     * one last time.
	     */

	    nsPtr ->flags |= NS_DEAD;
	} else {
	    /*
	     * Restore the ::errorInfo and ::errorCode traces.
	     */

	    EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0);
	    EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0);

	    /*
	     * We didn't really kill it, so remove the KILLED marks, so it can
	     * get killed later, avoiding mem leaks.
	     */

	    nsPtr->flags &= ~(NS_DYING|NS_KILLED);

    /*
     * The namespace is only deleted if it hasn't already been deleted. [Bug
     * 2950259].
     */

    if (!Destructing(oPtr)) {
	/*
	 * Ensure that we don't recurse very deeply and blow out the C stack.
	 * [Bug 02977e0004]
	 */
	ThreadLocalData *tsdPtr = GetFoundation(interp)->tsdPtr;
	if (oPtr->classPtr) {
	    /*
	     * Classes currently need the recursion to get destructor calling
	     * right. This is a bug, but it requires a major rewrite of things
	     * to fix. 
	     */
	    Tcl_DeleteNamespace(oPtr->namespacePtr);
	    oPtr->command = NULL;
	    TclOODecrRefCount(oPtr);
	} else if (!tsdPtr->delQueueTail) {
	    /*
	     * Process a queue of objects to delete.
	     */
	    Object *currPtr, *tmp;
	    tsdPtr->delQueueTail = oPtr;
	    for (currPtr = oPtr; currPtr; currPtr = tmp) {
		Tcl_DeleteNamespace(currPtr->namespacePtr);
		currPtr->command = NULL;
		tmp = currPtr->delNext;
		TclOODecrRefCount(currPtr);
	    }
	    tsdPtr->delQueueTail = NULL;
	} else {
	    /*
	     * Enqueue the object.
	     */
	    tsdPtr->delQueueTail->delNext = oPtr;
	    tsdPtr->delQueueTail = oPtr;
	}
    } else {
	oPtr->command = NULL;
	TclOODecrRefCount(oPtr);
    }
    return;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODeleteDescendants --

{
    Object *oPtr = clientData;
    Foundation *fPtr = oPtr->fPtr;
    FOREACH_HASH_DECLS;
    Class *mixinPtr;
    Method *mPtr;
    Tcl_Obj *filterObj, *variableObj;
    Tcl_Interp *interp = fPtr->interp;
    int i;

    if (Destructing(oPtr)) {
	/*
	 * TODO:  Can ObjectNamespaceDeleted ever be called twice?  If not,
	 * this guard could be removed.
	 */

     * in that case when the destructor is partially deleted before the uses
     * of it have gone. [Bug 2949397]
     */

    if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
	CallContext *contextPtr =
		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);



	oPtr->flags |= DESTRUCTOR_CALLED;

	if (contextPtr != NULL) {
	    int result;
	    Tcl_InterpState state;

	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
		    contextPtr, 0, NULL);
	    if (result != TCL_OK) {
		Tcl_BackgroundException(interp, result);

	 */
    } else {
	/*
	 * The namespace must have been deleted directly.  Delete the command
	 * as well.
	 */

	Tcl_DeleteCommandFromToken(interp, oPtr->command);
    }

    if (oPtr->myCommand) {
	Tcl_DeleteCommandFromToken(interp, oPtr->myCommand);
    }

    /*
     * Splice the object out of its context. After this, we must *not* call
     * methods on the object.
     */

     * class of classes now as well. Due to the incestuous nature of those two
     * classes, if one goes the other must too and yet the tangle can
     * sometimes not go away automatically; we force it here. [Bug 2962664]
     */

    if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr)
	    && !Tcl_InterpDeleted(interp)) {

	Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
    }

    if (oPtr->classPtr != NULL) {
	TclOOReleaseClassContents(interp, oPtr);
    }

    Tcl_Obj *cachedNameObj;	/* Cache of the name of the object. */
    Tcl_HashTable *chainCache;	/* Place to keep unused contexts. This table
				 * is indexed by method name as Tcl_Obj. */
    Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
				/* Function to allow remapping of method
				 * names. For itcl-ng. */
    LIST_STATIC(Tcl_Obj *) variables;
    struct Object *delNext;	/* If non-NULL, the next object to have its
				 * namespace deleted. */
} Object;

#define OBJECT_DESTRUCTING	1	/* Indicates that an object is being or has
								 *  been destroyed  */
#define DESTRUCTOR_CALLED 2	/* Indicates that evaluation of destructor script for the
							   object has began */
#define OO_UNUSED_4	4	/* No longer used.  */

typedef struct ThreadLocalData {
    int nsCount;		/* Epoch counter is used for keeping
				 * the values used in Tcl_Obj internal
				 * representations sane. Must be thread-local
				 * because Tcl_Objs can cross interpreter
				 * boundaries within a thread (objects don't
				 * generally cross threads). */
    Object *delQueueTail;	/* The tail object in the deletion queue. If
				 * NULL, there is no deletion queue. */
} ThreadLocalData;

typedef struct Foundation {
    Tcl_Interp *interp;
    Class *objectCls;		/* The root of the object system. */
    Class *classCls;		/* The class of all classes. */
    Tcl_Namespace *ooNs;	/* ::oo namespace. */

	return $::deathOrder
    }} 5
} -cleanup {
    parent destroy
} -result {1 2 3 4 0}
test oo-1.23 {basic test of OO functionality: deep nested ownership} -setup {
    oo::class create parent
} -body {
    oo::class create abc {
	superclass parent
	method make {} {[self class] create xyz}
	destructor {incr ::count}
    }
    apply {n {
	set ::count 0
	# Make a lot of "nested" objects
	set base [abc new]
	for {set i 1; set obj $base} {$i < $n} {incr i} {
	     set obj [$obj make]
	}
	# Kill them all in one go; should not crash!
	$base destroy
	return [expr {$n - $::count}]
    }} 10000
} -cleanup {
    parent destroy
} -result 0
test oo-1.24 {basic test of OO functionality: deep nested ownership} -setup {
    oo::class create parent
} -constraints knownBug -body {
    oo::class create abc {
	superclass parent
	self method make {} {oo::copy [self] xyz}
	destructor {incr ::count}
    }
    apply {n {
	set ::count 0
	# Make a lot of "nested" objects
	set base abc
	for {set i 1; set obj $base} {$i < $n} {incr i} {
	     set obj [$obj make]
	}
	# Kill them all in one go; should not crash!
	$base destroy
	return [expr {$n - $::count}]
    }} 10000